( w65c816 assembler )

hex
: << lshift ;
: >> rshift ;
: lo ff and ;
: hi 8 >> lo ;
: 2^ 1 swap << ;

include segment.fs

: check8s ( s -- )
  -$80 $7f within 0=
  abort" 8bit signed out of range" ;

: check16s ( s -- )
  -$8000 $7fff within 0=
  abort" 16bit signed out of range" ;

: checksamebank ( dest src -- )
  swap $ff0000 and swap $ff0000 and <>
  abort" source and destination must be in same bank" ;

: bankoffset ( dest src -- offset )
  2dup checksamebank
  swap $8000 + $ffff and
  swap $8000 + $ffff and - ;

: invalid-instruction ( -- )
  true abort" invalid instruction" ;

( processor status bits )

$01 constant cbit
$02 constant zbit
$04 constant ibit
$08 constant dbit
$10 constant xbit
$20 constant mbit
$40 constant vbit
$80 constant nbit

( variants )
$0 constant w6502
$1 constant w65c02
$2 constant w65c816
$3 constant w65none

variable variant

: checkvariant ( variant -- )
  variant @ > abort" invalid opcode" ;

( addressing modes )

variable amode

#00 constant @a      ( absolute )
#01 constant A       ( accumulator )
#02 constant a,x     ( absolute indexed with x )
#03 constant a,y     ( absolute indexed with y )
#04 constant @al     ( absolute long )
#05 constant al,x    ( absolute long indexed with x )
#06 constant (a)     ( absolute indirect )
#07 constant (a,x)   ( absolute indexed indirect )
#08 constant @d      ( direct )
#09 constant d,s     ( stack relative )
#10 constant d,x     ( direct indexed with x )
#11 constant d,y     ( direct indexed with y )
#12 constant (d)     ( direct indirect )
#13 constant [d]     ( direct indirect long )
#14 constant (d,s),y ( stack relative indirect indexed )
#15 constant (d,x)   ( direct indexed indirect )
#16 constant (d),y   ( direct indirect indexed )
#17 constant [d],y   ( direct indirect long indexed )
#18 constant #       ( immediate )

#19 constant #modes

\ a ,x ,y () (,x) ,s [] (,s),y (),y [],y #

( implied )
: imp ( opcode variant "" -- ) ( D: -- )
  2 0 const-does> checkvariant t1, ;

$08 w6502   imp php,
$0b w65c816 imp phd,
$18 w6502   imp clc,
$1b w65c816 imp tcs,
$28 w6502   imp plp,
$2b w65c816 imp pld,
$38 w6502   imp sec,
$3b w65c816 imp tsc,
$40 w6502   imp rti,
$42 w65c816 imp wdm,
$48 w6502   imp pha,
$4b w65c816 imp phk,
$58 w6502   imp cli,
$5a w65c02  imp phy,
$5b w65c816 imp tcd,
$60 w6502   imp rts,
$68 w6502   imp pla,
$6b w65c816 imp rtl,
$78 w6502   imp sei,
$7a w65c02  imp ply,
$7b w65c816 imp tdc,
$88 w6502   imp dey,
$8a w6502   imp txa,
$8b w65c816 imp phb,
$98 w6502   imp tya,
$9a w6502   imp txs,
$9b w65c816 imp txy,
$a8 w6502   imp tay,
$aa w6502   imp tax,
$ab w65c816 imp plb,
$b8 w6502   imp clv,
$ba w6502   imp tsx,
$bb w65c816 imp tyx,
$c8 w6502   imp iny,
$ca w6502   imp dex,
$cb w65c816 imp wai,
$d8 w6502   imp cld,
$da w65c02  imp phx,
$db w65c816 imp stp,
$e8 w6502   imp inx,
$ea w6502   imp nop,
$eb w65c816 imp xba,
$f8 w6502   imp sed,
$fa w65c02  imp plx,
$fb w65c816 imp xce,

( relative )
: rel ( opcode variant "" -- ) ( D: dest -- )
  2 0 const-does> checkvariant >r
    there 2 + bankoffset
    dup check8s
    r> t1, t1, ;

$10 w6502   rel bpl,
$30 w6502   rel bmi,
$50 w6502   rel bvc,
$70 w6502   rel bvs,
$80 w65c02  rel bra,
$90 w6502   rel bcc,
$b0 w6502   rel bcs,
$d0 w6502   rel bne,
$f0 w6502   rel beq,

( relative long )
: rellong ( opcode variant "" -- ) ( D: dest -- )
  2 0 const-does> checkvariant >r
    there 3 + bankoffset
    dup check16s
    r> t1, t2, ;

$62 w65c816 rellong per,
$82 w65c816 rellong brl,

( one byte signature )
: sig ( opcode variant "" -- ) ( D: operand -- )
  2 0 const-does> checkvariant t1, t1, ;

( stack )
$00 w6502   sig brk,
$02 w65c816 sig cop,

( immediate )
$c2 w65c816 sig rep,
$e2 w65c816 sig sep,

: xyc ( opcode variant "" -- ) ( D: dest src -- )
  2 0 const-does> checkvariant t1, swap t1, t1, ;

$44 w65c816 xyc mvp,
$54 w65c816 xyc mvn,

( operation size )

$0 constant opsize0
$1 constant opsize1
$2 constant opsize2
$3 constant opsizem
$4 constant opsizex

( immediate mode )

variable preg $00 preg !

: immbybit ( imm pregbit -- )
  preg @ and if t1, else t2, then ;

: imm, ( imm opsize -- )
  case
    opsize1 of t1, endof
    opsize2 of t2, endof
    opsizem of mbit immbybit endof
    opsizex of xbit immbybit endof
    true abort" invalid opsize"
  endcase ;

( instruction table )

struct
  char% field inst>variant
  char% field inst>opcode
end-struct inst%

variable #opcodes 0 #opcodes !

defer (op)

struct
  cell% field op>id
  cell% field op>size
end-struct op%

: op ( opsize "" -- )
  create op% %allot
    swap over op>size !
    #opcodes @ over op>id !
    #modes #opcodes +!
    drop
  does> (op) ;

opsizem op adc,
opsizem op and,
opsizem op asl,
opsizem op bit,
opsizem op cmp,
opsizex op cpx,
opsizex op cpy,
opsizem op dec,
opsizem op eor,
opsizem op inc,
opsize0 op jml,
opsize0 op jmp,
opsize0 op jsl,
opsize0 op jsr,
opsizem op lda,
opsizex op ldx,
opsizex op ldy,
opsizem op lsr,
opsizem op ora,
opsize2 op pea,
opsize2 op pei,
opsizem op rol,
opsizem op ror,
opsizem op sbc,
opsizem op sta,
opsizex op stx,
opsizex op sty,
opsizem op stz,
opsizem op trb,
opsizem op tsb,

inst% #opcodes @ * %allot constant opcodes
: opcode[] inst% %size * opcodes + ;
: inst-init ( -- ) #opcodes @ 0 do w65none i opcode[] inst>variant c! loop ;
inst-init

: op-init ( opcode variant mode op -- )
  op>id @ + opcode[]
    swap over inst>variant c!
              inst>opcode  c! ;

' op-init is (op)

$01 w6502   (d,x)   ora,
$03 w65c816 d,s     ora,
$04 w65c02  @d      tsb,
$05 w6502   @d      ora,
$06 w6502   @d      asl,
$07 w65c816 [d]     ora,
$09 w6502   #       ora,
$0a w6502   A       asl,
$0c w65c02  @a      tsb,
$0d w6502   @a      ora,
$0e w6502   @a      asl,
$0f w65c816 @al     ora,
$11 w6502   (d),y   ora,
$12 w65c02  (d)     ora,
$13 w65c816 (d,s),y ora,
$14 w65c02  @d      trb,
$15 w6502   d,x     ora,
$16 w6502   d,x     asl,
$17 w65c816 [d],y   ora,
$19 w6502   a,y     ora,
$1a w65c02  A       inc,
$1c w65c02  @a      trb,
$1d w6502   a,x     ora,
$1e w6502   a,x     asl,
$1f w65c816 al,x    ora,
$20 w6502   @a      jsr,
$21 w6502   (d,x)   and,
$22 w65c816 @al     jsl,
$23 w65c816 d,s     and,
$24 w6502   @d      bit,
$25 w6502   @d      and,
$26 w6502   @d      rol,
$27 w65c816 [d]     and,
$29 w6502   #       and,
$2a w6502   A       rol,
$2c w6502   @a      bit,
$2d w6502   @a      and,
$2e w6502   @a      rol,
$2f w65c816 @al     and,
$31 w6502   (d),y   and,
$32 w65c02  (d)     and,
$33 w65c816 (d,s),y and,
$34 w65c02  d,x     bit,
$35 w6502   d,x     and,
$36 w6502   d,x     rol,
$37 w65c816 [d],y   and,
$39 w6502   a,y     and,
$3a w65c02  A       dec,
$3c w65c02  a,x     bit,
$3d w6502   a,x     and,
$3e w6502   a,x     rol,
$3f w65c816 al,x    and,
$41 w6502   (d,x)   eor,
$43 w65c816 d,s     eor,
$45 w6502   @d      eor,
$46 w6502   @d      lsr,
$47 w65c816 [d]     eor,
$49 w6502   #       eor,
$4a w6502   A       lsr,
$4c w6502   @a      jmp,
$4d w6502   @a      eor,
$4e w6502   @a      lsr,
$4f w65c816 @al     eor,
$51 w6502   (d),y   eor,
$52 w65c02  (d)     eor,
$53 w65c816 (d,s),y eor,
$55 w6502   d,x     eor,
$56 w6502   d,x     lsr,
$57 w65c816 [d],y   eor,
$59 w6502   a,y     eor,
$5c w65c816 @al     jmp,
$5d w6502   a,x     eor,
$5e w6502   a,x     lsr,
$5f w65c816 al,x    eor,
$61 w6502   (d,x)   adc,
$63 w65c816 d,s     adc,
$64 w65c02  @d      stz,
$65 w6502   @d      adc,
$66 w6502   @d      ror,
$67 w65c816 [d]     adc,
$69 w6502   #       adc,
$6a w6502   A       ror,
$6c w6502   (a)     jmp,
$6d w6502   @a      adc,
$6e w6502   @a      ror,
$6f w65c816 @al     adc,
$71 w6502   (d),y   adc,
$72 w65c02  (d)     adc,
$73 w65c816 (d,s),y adc,
$74 w65c02  d,x     stz,
$75 w6502   d,x     adc,
$76 w6502   d,x     ror,
$77 w65c816 [d],y   adc,
$79 w6502   a,y     adc,
$7c w65c02  (a,x)   jmp,
$7d w6502   a,x     adc,
$7e w6502   a,x     ror,
$7f w65c816 al,x    adc,
$81 w6502   (d,x)   sta,
$83 w65c816 d,s     sta,
$84 w6502   @d      sty,
$85 w6502   @d      sta,
$86 w6502   @d      stx,
$87 w65c816 [d]     sta,
$89 w65c02  #       bit,
$8c w6502   @a      sty,
$8d w6502   @a      sta,
$8e w6502   @a      stx,
$8f w65c816 @al     sta,
$91 w6502   (d),y   sta,
$92 w65c02  (d)     sta,
$93 w65c816 (d,s),y sta,
$94 w6502   d,x     sty,
$95 w6502   d,x     sta,
$96 w6502   d,y     stx,
$97 w65c816 [d],y   sta,
$99 w6502   a,y     sta,
$9c w65c02  @a      stz,
$9d w6502   a,x     sta,
$9e w65c02  a,x     stz,
$9f w65c816 al,x    sta,
$a0 w6502   #       ldy,
$a1 w6502   (d,x)   lda,
$a2 w6502   #       ldx,
$a3 w65c816 d,s     lda,
$a4 w6502   @d      ldy,
$a5 w6502   @d      lda,
$a6 w6502   @d      ldx,
$a7 w65c816 [d]     lda,
$a9 w6502   #       lda,
$ac w6502   @a      ldy,
$ad w6502   @a      lda,
$ae w6502   @a      ldx,
$af w65c816 @al     lda,
$b1 w6502   (d),y   lda,
$b2 w65c02  (d)     lda,
$b3 w65c816 (d,s),y lda,
$b4 w6502   d,x     ldy,
$b5 w6502   d,x     lda,
$b6 w6502   d,y     ldx,
$b7 w65c816 [d],y   lda,
$b9 w6502   a,y     lda,
$bc w6502   a,x     ldy,
$bd w6502   a,x     lda,
$be w6502   a,y     ldx,
$bf w65c816 al,x    lda,
$c0 w6502   #       cpy,
$c1 w6502   (d,x)   cmp,
$c3 w65c816 d,s     cmp,
$c4 w6502   @d      cpy,
$c5 w6502   @d      cmp,
$c6 w6502   @d      dec,
$c7 w65c816 [d]     cmp,
$c9 w6502   #       cmp,
$cc w6502   @a      cpy,
$cd w6502   @a      cmp,
$ce w6502   @a      dec,
$cf w65c816 @al     cmp,
$d1 w6502   (d),y   cmp,
$d2 w65c02  (d)     cmp,
$d3 w65c816 (d,s),y cmp,
$d4 w65c816 @d      pei,
$d5 w6502   d,x     cmp,
$d6 w6502   d,x     dec,
$d7 w65c816 [d],y   cmp,
$d9 w6502   a,y     cmp,
$dc w65c816 (a)     jml,
$dd w6502   a,x     cmp,
$de w6502   a,x     dec,
$df w65c816 al,x    cmp,
$e0 w6502   #       cpx,
$e1 w6502   (d,x)   sbc,
$e3 w65c816 d,s     sbc,
$e4 w6502   @d      cpx,
$e5 w6502   @d      sbc,
$e6 w6502   @d      inc,
$e7 w65c816 [d]     sbc,
$e9 w6502   #       sbc,
$ec w6502   @a      cpx,
$ed w6502   @a      sbc,
$ee w6502   @a      inc,
$ef w65c816 @al     sbc,
$f1 w6502   (d),y   sbc,
$f2 w65c02  (d)     sbc,
$f3 w65c816 (d,s),y sbc,
$f4 w65c816 @a      pea,
$f4 w65c816 #       pea,
$f5 w6502   d,x     sbc,
$f6 w6502   d,x     inc,
$f7 w65c816 [d],y   sbc,
$f9 w6502   a,y     sbc,
$fc w65c816 (a,x)   jsr,
$fd w6502   a,x     sbc,
$fe w6502   a,x     inc,
$ff w65c816 al,x    sbc,

: op-asm ( operand mode op -- ) >r
  dup r@ op>id @ + opcode[]
  dup inst>variant c@ checkvariant
      inst>opcode c@ t1,
  case
    @a      of a2, endof
    A       of     endof
    a,x     of a2, endof
    a,y     of a2, endof
    @al     of a3, endof
    al,x    of a3, endof
    (a)     of a2, endof
    (a,x)   of a2, endof
    @d      of t1, endof
    d,s     of t1, endof
    d,x     of t1, endof
    d,y     of t1, endof
    (d)     of t1, endof
    [d]     of t1, endof
    (d,s),y of t1, endof
    (d,x)   of t1, endof
    (d),y   of t1, endof
    [d],y   of t1, endof
    #       of r@ op>size @ imm, endof
    true abort" invalid mode"
  endcase rdrop ;

' op-asm is (op)

: label create there , does> @ ;
: var ( size "" -- ) label tallot ;

( conditionals )

$00 constant sign
$40 constant overflow
$80 constant carry
$c0 constant zero

:  if, ( cc -- a ) there swap $10 + t1, $00 t1, ;
: ~if, ( cc -- a ) there swap $30 + t1, $00 t1, ;
: then, ( a -- ) there over $2 + bankoffset dup check8s
  swap $1 + t1! ;
: else, ( a1 -- a2 ) there $80 t1, $00 t1, swap then, ;

( loops )

: begin, ( -- a ) there ;
: again, ( a -- ) @a jmp, ;
: until, ( a cc -- ) $10 + t1, there 1 + bankoffset dup check8s t1, ;
: ~until, ( a cc -- ) $30 + t1, there 1 + bankoffset dup check8s t1, ;
: do, ( -- a ) there ;
: while, ( a cc -- a a ) if, swap ;
: ~while, ( a cc -- a a ) ~if, swap ;
: repeat, ( a a -- ) again, then, ;

( set register size in assembler only )

: short ( pbits -- ) preg @ or preg ! ;
: long  ( pbits -- ) invert preg @ and preg ! ;

( set register size in assembler and hardware )

: short, ( pbits -- ) dup short sep, ;
: long,  ( pbits -- ) dup long  rep, ;

( get register size )

: size' ( pbit -- size )
  variant @ w65c816 >= if
    preg @ and 0<> if $1 else $2 then
  else
    drop $1
  then ;

: msize ( -- msize ) mbit size' ;
: xsize ( -- xsize ) xbit size' ;

